home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / tptc16.zip / TPCUNIT.INC < prev    next >
Text File  |  1993-01-04  |  11KB  |  556 lines
  1.  
  2. (*
  3.  * TPTC - Turbo Pascal to C translator
  4.  *
  5.  * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
  6.  *
  7.  *)
  8.  
  9.  
  10. (********************************************************************)
  11. (*
  12.  * process generic declaration section
  13.  *   dispatches to const, type, var, proc, func
  14.  *   enter with tok=section type
  15.  *   exit with tok=next section type
  16.  *
  17.  *)
  18.  
  19. procedure psection;
  20. begin
  21.  
  22.    if tok = 'EXTERNAL' then
  23.       punit
  24.    else
  25.  
  26.    if tok = 'OVERLAY' then
  27.       punit
  28.    else
  29.  
  30.    if tok = 'PROCEDURE' then
  31.       punit
  32.    else
  33.  
  34.    if tok = 'FUNCTION' then
  35.       punit
  36.    else
  37.  
  38.    if tok = 'CONST' then
  39.       pconst
  40.    else
  41.  
  42.    if tok = 'TYPE' then
  43.       ptype
  44.    else
  45.  
  46.    if tok = 'VAR' then
  47.       pvar
  48.    else
  49.  
  50.    if tok = 'LABEL' then
  51.       plabel
  52.    else
  53.  
  54.    if tok = '{' then
  55.       pblock
  56.    else
  57.  
  58.    if tok = '.' then
  59.       exit
  60.  
  61.    else
  62.       syntax('Section header expected (psection)');
  63. end;
  64.  
  65.  
  66. (********************************************************************)
  67. (*
  68.  * process argument declarations to
  69.  *    program, procedure, function
  70.  *
  71.  * enter with header as tok
  72.  * exits with tok as ; or :
  73.  *
  74.  *)
  75.  
  76. function punitheader(ext: boolean): anystring;
  77. var
  78.    proc:  string80;
  79.    vars:  paramlist;
  80.    types: paramlist;
  81.    i:     integer;
  82.    ii:    integer;
  83.    rtype: string80;
  84.    varval:integer;
  85.    varon: boolean;
  86.    locvar:integer;
  87.    iptr:  integer;
  88.  
  89. begin
  90.    nospace := true;
  91.    gettok;                 {skip unit type}
  92.  
  93.    proc := ltok;
  94.    punitheader := proc;
  95.    if unitlevel > 1 then
  96.       error('Enter nested function');
  97.  
  98.    gettok;                 {skip unit identifier}
  99.  
  100.    vars.n := 0;
  101.    varval := 0;       { 0 bit means value, 1 = var }
  102.    varon  := false;
  103.  
  104.    (* process param list, if any *)
  105.    if tok = '(' then
  106.    begin
  107.  
  108.       gettok;
  109.  
  110.       while tok <> ')' do
  111.       begin
  112.  
  113.          ii := vars.n + 1;
  114.          repeat
  115.             if tok = ',' then
  116.                gettok;
  117.  
  118.             if tok = 'VAR' then
  119.             begin
  120.                gettok;
  121.                varon := true;
  122.             end;
  123.  
  124.             inc(vars.n);
  125.             vars.id[vars.n] := ltok;
  126.             gettok;
  127.  
  128.          until tok <> ',';
  129.  
  130.          if tok <> ':' then
  131.          begin
  132.             syntax('":" expected (punitheader)');
  133.             exit;
  134.          end;
  135.  
  136.          gettok;   {consume the :}
  137.  
  138.          {parse the param type}
  139.          rtype := psimpletype;
  140.          iptr := 0;
  141.  
  142.          if rtype[1] = '^' then
  143.             rtype[1] := '*';
  144.  
  145.          if (not varon) then
  146.          begin
  147.             if (curtype = s_string) then
  148.                rtype := 'char *'
  149.             else
  150.             if cursuptype = ss_array then
  151.                iptr := 1 shl (ii - 1);
  152.          end;
  153.  
  154. {        for i := ii to vars.n-1 do
  155.             if varon then
  156.                varval := varval or (1 shl ii);   }
  157.  
  158.          for i := ii to vars.n do   {assign data types}
  159.          begin
  160.             types.id[i] := rtype;
  161.             types.stype[i] := curtype;
  162.             types.sstype[i] := cursuptype;
  163.             varval := varval or iptr;
  164.             iptr := iptr shl 1;
  165.          end;
  166.  
  167.          if (tok = ';') then
  168.          begin
  169.             gettok;
  170.             varon := false;
  171.          end;
  172.  
  173.       end;   {) seen}
  174.  
  175.       gettok;   {consume the )}
  176.    end;
  177.  
  178.    (* process function return type, if any *)
  179.    if tok = ':' then
  180.    begin
  181.       gettok;            {consume the :}
  182.       rtype := psimpletype;
  183.  
  184.       if curtype = s_string then
  185.          rtype := 'char *'
  186.       else
  187.       if cursuptype = ss_array then
  188.          rtype := typename[curtype] + ' *';
  189.    end
  190.    else
  191.  
  192.    begin
  193.       rtype := 'void ';
  194.       curtype := s_void;
  195.    end;
  196.  
  197.    writeln(ofd[level]);
  198.  
  199.    (* prefix procedure decl's when external *)
  200.    if ext then
  201.    begin
  202.       writeln(ofd[level],'extern ',LJUST(rtype,identlen),' ',proc,'();');
  203.       addsym(globals,proc,curtype,ss_func,0,0,varval);
  204.       exit;
  205.    end;
  206.  
  207.    (* output the return type, proc name, formal param list *)
  208.    write(ofd[level],LJUST(rtype,identlen),' ',proc,'(');
  209.  
  210.    if vars.n = 0 then
  211.       write(ofd[level],'void');
  212.  
  213.    (* output the formal param declarations *)
  214.    locvar := varval;
  215.    for i := 1 to vars.n do
  216.    begin
  217.       iptr := -1;
  218.  
  219.       if (locvar and 1) = 1 then
  220.       begin
  221.          iptr := -2;
  222.          types.id[i] := types.id[i] + ' *';
  223.       end;
  224.  
  225.       write(ofd[level],LJUST(types.id[i],identlen),vars.id[i]);
  226.       newsym(vars.id[i],types.stype[i],ss_scalar,iptr,0,0);
  227.       locvar := locvar shr 1;
  228.  
  229.       if i < vars.n then
  230.       begin
  231.          writeln(ofd[level],',');
  232.          write(ofd[level],'':identlen+length(proc)+2);
  233.       end;
  234.    end;
  235.  
  236.    write(ofd[level],') ');
  237.  
  238.    addsym(globals,proc,curtype,ss_func,vars.n,0,varval);
  239.    nospace := false;
  240. end;
  241.  
  242.  
  243. (********************************************************************)
  244. (*
  245.  * process body of program unit
  246.  *   handles all declaration sections
  247.  *   and a single begin...end
  248.  *   recursively handles procedure declarations
  249.  *   ends with tok=}
  250.  *)
  251.  
  252. procedure punitbody;
  253. begin
  254.    gettok;
  255.  
  256.    if tok <> 'FORWARD' then
  257.    begin
  258.       write(ofd[level],'{ ');
  259.  
  260.       repeat
  261.          if tok = ';' then
  262.          begin
  263.             puttok;
  264.             gettok;
  265.          end;
  266.  
  267.          if tok <> '{' then
  268.             psection;
  269.       until tok = '{';
  270.  
  271.       gettok;                 {get first token of first statement}
  272.  
  273.       while tok <> '}' do
  274.       begin
  275.          pstatement;                {process the statement}
  276.  
  277.          if tok = ';' then
  278.          begin
  279.             puttok;
  280.             gettok;              {get first token of next statement}
  281.          end;
  282.       end;
  283.  
  284.       puttok;
  285.       writeln(ofd[level]);
  286.  
  287.    end    {if not FORWARD}
  288.  
  289.    else
  290.    begin
  291.       write(ofd[level],'/* forward */ ;');
  292.       gettok;
  293.    end;
  294.  
  295. end;
  296.  
  297.  
  298. (********************************************************************)
  299. function makename(n: integer): anystring;
  300. var
  301.    nam:  anystring;
  302. begin
  303.    str(n,nam);
  304.    makename := nestfile + nam;
  305. end;
  306.  
  307. (********************************************************************)
  308. procedure enter_nested;
  309. begin
  310.    inc(level);
  311.    assign(ofd[level],makename(level));
  312.    rewrite(ofd[level]);
  313. end;
  314.  
  315.  
  316. (********************************************************************)
  317. procedure exit_nested;
  318. var
  319.    nfd:   text;
  320.    line:  anystring;
  321.  
  322. begin
  323.    writeln(ofd[level]);
  324.    close(ofd[level]);
  325.    reset(ofd[level]);
  326.  
  327.    assign(nfd,nestfile);
  328.    {$i-} append(nfd); {$i+}
  329.    if ioresult <>0 then
  330.       rewrite(nfd);
  331.  
  332.    while not eof(ofd[level]) do
  333.    begin
  334.       readln(ofd[level],line);
  335.       writeln(nfd,line);
  336.    end;
  337.  
  338.    close(ofd[level]);
  339.    erase(ofd[level]);
  340.    close(nfd);
  341.  
  342.    dec(level);
  343.  
  344. end;
  345.  
  346.  
  347. (********************************************************************)
  348. procedure discard_nested;
  349. var
  350.    nfd:   text;
  351.  
  352. begin
  353.    {$i-}
  354.    close(ofd[level]);
  355.    erase(ofd[level]);
  356.    assign(nfd,nestfile);
  357.    rewrite(nfd);
  358.    writeln(nfd);
  359.    close(nfd);
  360.    {$i+}
  361.  
  362.    dec(level);
  363. end;
  364.  
  365.  
  366. (********************************************************************)
  367. procedure append_nested;
  368. var
  369.    nfd:   text;
  370.    line:  anystring;
  371.  
  372. begin
  373.    assign(nfd,nestfile);
  374.    {$i-} reset(nfd); {$i+}
  375.    if ioresult <> 0 then
  376.       exit;
  377.  
  378.    while not eof(nfd) do
  379.    begin
  380.       readln(nfd,line);
  381.       writeln(ofd[level],line);
  382.    end;
  383.  
  384.    close(nfd);
  385.    erase(nfd);
  386. end;
  387.  
  388.  
  389. (********************************************************************)
  390. (*
  391.  * process program, procedure and function declaration
  392.  *
  393.  * enter with tok=function
  394.  * exit with tok=;
  395.  *
  396.  *)
  397.  
  398. procedure punit;
  399. var
  400.    proc:  anystring;
  401.    xxx:   char;
  402.  
  403. begin
  404.    inc(unitlevel);
  405.  
  406.    if (tok = 'OVERLAY') then
  407.       gettok;
  408.  
  409.    if (tok = 'EXTERNAL') then  {mt+}
  410.    begin
  411.       gettok;      {consume the EXTERNAL}
  412.  
  413.       if tok = '[' then
  414.       begin
  415.          gettok;   {consume the '['}
  416.  
  417.          write(ofd[level],'/* overlay ',ltok,' */ ');
  418.          gettok;   {consume the overlay number}
  419.  
  420.          gettok;   {consume the ']'}
  421.       end;
  422.  
  423.       proc := punitheader(true);
  424.  
  425.       if tok = ';' then
  426.          gettok;
  427.    end
  428.    else
  429.  
  430.    begin
  431.       if unitlevel > 1 then
  432.       begin
  433.          writeln;
  434.          enter_nested;
  435.          srclines[level] := srclines[level-1];
  436.          if locals^.id <> localseprt then
  437.             newsym(localseprt, s_int, ss_scalar, -1,0,0);
  438.       end;
  439.  
  440.       proc := punitheader(false);
  441.       punitbody;
  442.  
  443.       if unitlevel > 1 then
  444.       begin
  445.          tok := proc;
  446.          error('Exit nested function');
  447.  
  448.          exit_nested;
  449.          srclines[level] := srclines[level+1];
  450.          purgefrom(localseprt);
  451.       end
  452.       else
  453.  
  454.       begin
  455.          append_nested;
  456.  
  457.          inc(nestn[2]);
  458.          if nestn[2] > '9' then
  459.          begin
  460.             inc(nestn[1]);
  461.             nestn[2] := '0';
  462.          end;
  463.       end;
  464.  
  465.      gettok;
  466.      if tok = ';' then
  467.         gettok;
  468.  
  469.    end;
  470.  
  471.    dec(unitlevel);
  472.  
  473.    if unitlevel = 0 then
  474.       purgetable(locals);
  475.  
  476. end;
  477.  
  478.  
  479.  
  480. (********************************************************************)
  481. (*
  482.  * process main program
  483.  *
  484.  *  expects program head
  485.  *  optional declarations
  486.  *  block of main code
  487.  *  .
  488.  *
  489.  *)
  490.  
  491. procedure pprogram;
  492. begin
  493.    writeln(ofd[level]);
  494.    writeln(ofd[level],'/*');
  495.    writeln(ofd[level],' * Generated by ',version1);
  496.    writeln(ofd[level],' *    ',version2);
  497.    writeln(ofd[level],' */');
  498.    writeln(ofd[level]);
  499.    writeln(ofd[level],'#include "tptcmac.h"');
  500.  
  501.    getchar;  {get first char}
  502.    gettok;   {get first token}
  503.  
  504.    if (tok = 'PROGRAM') or (tok = 'UNIT') then
  505.    begin
  506.       repeat
  507.          gettok;
  508.       until tok = ';';
  509.       gettok;
  510.    end;
  511.  
  512.    if tok = 'MODULE' then
  513.    begin
  514.       mt_plus := true;   {shift into pascal/mt+ mode}
  515.       repeat
  516.          gettok;
  517.       until tok = ';';
  518.       gettok;
  519.    end;
  520.  
  521.    repeat
  522.       if tok = ';' then
  523.       begin
  524.          puttok;
  525.          gettok;
  526.       end;
  527.  
  528.       if tok = 'MODEND' then
  529.          exit;
  530.  
  531.       if (tok <> '{') then
  532.          psection;
  533.    until (tok = '{');
  534.  
  535.    writeln(ofd[level]);
  536.    writeln(ofd[level],'main(int    argc,');
  537.    writeln(ofd[level],'     char   *argv[])');
  538.  
  539.    puttok;
  540.    gettok;                 {get first token of main block}
  541.  
  542.    while tok <> '}' do
  543.    begin
  544.       pstatement;                {process the statement}
  545.  
  546.       if tok = ';' then
  547.       begin
  548.          puttok;
  549.          gettok;              {get first token of next statement}
  550.       end;
  551.    end;
  552.  
  553.    puttok;
  554.    writeln(ofd[level]);
  555. end;
  556.